home *** CD-ROM | disk | FTP | other *** search
/ BMUG Revelations / BMUG Revelations.toast / Programming / Programming Languages / Yerk 3.64 / Toolbox Classes / vScroll < prev   
Text File  |  1988-08-31  |  2KB  |  56 lines
  1. \ VScroll - Control subclass for vertical scroll bars
  2. \ 12/17/84  cbd Version 1
  3. \ 12/26/85  cdn Added clear: parts to actions:
  4. \  1/31/86  rfl added last line oin new: to make consistent with ctl.rfl
  5. Decimal
  6.  
  7. \ myCtl returns the address of the owning control for a control
  8. \ action handler.  It is the second object down on the mstack.
  9. 'c mp0 vect myCtl
  10.  
  11. :CLASS vScroll  <Super Control
  12.  
  13.     5 Ordered-Col    Parts
  14.     5 X-Array        Actions
  15.  
  16.     \ load the actions for the parts of the scroll bar
  17.     \ ( up dn pgUp pgDn thumb -- )
  18.     :M  ACTIONS: put: actions   clear: parts
  19.                 129 23 22 21 20 5 0 DO add: parts LOOP ;M
  20.  
  21.     \ ( part# -- )  perform action for part no.
  22.     :M  EXEC:  indexOf: parts
  23.         IF  exec: actions THEN    ;M
  24.  
  25.     :M  NEW:  { left top len wind -- }
  26.         left top left 16 + top len +
  27.         Put: tempRect  0 abs: Wind  Abs: tempRect nullosstr
  28.         w 256 word0 word0 w 1 w 16 ^base
  29.         call NewControl put: ctlhndl
  30.         ^base get: ctlhndl set-ctl-obj   
  31.         wind put: myWindow ;M   \ don't put self until setRange is called
  32.  
  33.     \ ( -- ) set the control to 255 hiliting (disabled)
  34.     :M  DISABLE:  255 hilite: super  ;M
  35.  
  36.     \ ( -- ) set all parts to enabled hiliting.
  37.     :M  ENABLE:  5 2 DO I at: parts hilite: self LOOP   ;M
  38.  
  39.     :M  CLASSINIT:  16 put: procID <[ 5 ]> 'cfas null null null null null
  40.         actions: self  ;M
  41.  
  42.     \ set the maximum and minimum values of the thumb
  43.     :M  PUTRANGE:  { lo hi -- }  get: ctlHndl lo makeInt call SetMinCtl
  44.         get: ctlHndl hi makeInt call SetMaxCtl  ;M
  45.  
  46.     \ ( -- )  show an example vertical scroll bar
  47.     :M  EXAMPLE:  { theWind -- }  100 50 80  theWind
  48.         new: self show: self 1 10 putRange: self  ;M
  49.  
  50. ;CLASS
  51.  
  52. \ define some typical handlers
  53. \ : lnUp  get: myCtl 1- 0 max put: myCtl ;
  54. \ : lnDn  get: myCtl 1+        put: myCtl ;
  55.  
  56.